home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Window < prev   
Encoding:
Text File  |  1996-03-18  |  10.1 KB  |  342 lines  |  [TEXT/YERK]
  1. \  5/07/84  NDI Version 1
  2. \  9/05/84  CBD Version 1.3
  3. \  9/07/84  CBD Fixed GetVRect:
  4. \ 11/22/84  cbd ctlHit, fixed drag:, grow:
  5. \ 12/08/85  cdn Modified enable: & disable: to flip-flop Null-Evt vectors
  6. \ 12/15/85  cdn Moved FinalSave to Util module
  7. \  4/15/86    cdn    Added Hide: method
  8. \  5/27/86  cdn Added idle vector; enable:/disable now set actW (active window)
  9. \  8/07/86  cdn Added deact vector & setact:
  10. \  8/12/86  cdn Removed extraneous drops in new:
  11. \ 12/26/87    rfl    could modify draw: to not set, but to set super to save fprect
  12. \ 11/06/90    rfl    example: now uses grayRgn for drag; simplified classinit
  13. \ 11/23/90    rfl    added grayRgn word
  14. \  3/22/91    rfl    because of complaints, growbox now erased on grow
  15. \  4/09/91    rfl    also, grow now computes to send next line to bottom if necessary
  16. \  4/29/91    rfl simplified eraseGrow:...but did not recompile source
  17. \ 10/21/91    rfl    added a lot of Michael Hore's window routines, grow box support, etc.
  18. \                moved screenbits from objinit
  19. \ 12/18/91    rfl    resID now stored with object, getnew: requires nothing on stack
  20. \ 12/27/91    rfl    drag no longer selects window...command key option works as in IM
  21. \  6/22/92    rfl    erasegrow: only works if grow flag is set
  22. \  9/28/92    rfl    added portBit:
  23. \ 10/18/92    rfl added 'part' as parameter for zoom handler...Used to have to use
  24. \                 mp2 to get zoom state from methods stack
  25. \  5/10/93    rfl    shortened getnew: and check for resource with error message
  26. \  5/29/93    rfl removed theWindow; changed thePort to myPort.
  27. \  1/03/94    rfl    added cut, copy and paste methods
  28. \  5/08/94    rfl fixed setlimits for grow:
  29. \  5/19/94    rfl    fixed getnew: bug by removing drop if window is alive
  30. \                   added cwindow support by flagging window object before instantiation
  31. \ 10/08/94    rfl    added SelectAll: as a null. for TEedits using editmenu command-A;
  32. \                added undo: as a null, too
  33. \ 11/5/95    rfl    removed select: window in grow: and changed grow: to call
  34. \                 content: if the window is not growable
  35. \  1/21/96    rfl    added update: to grow
  36.  
  37. Decimal
  38.  
  39.  -1  Constant  inFront
  40.   0  Variable  myPort
  41. 129  Constant  Thumb
  42.  
  43.   0  Constant  docWind
  44.  16  Constant  rndWind
  45.   1  Constant  dlgWind
  46.  
  47. : initFont  9 tsize 4 tfont 0 tMode 0 tFace  ;
  48. : grayRgn ( -- l t r b ) $ 9ee -base @ >ptr 2+ get: rect ;
  49.  
  50. \ save and restore the GrafPort
  51. : savePort   myPort +base call GetPort ;
  52. : restPort   myPort @  call SetPort ;
  53.  
  54. \ ( -- l t r b )  leave dimension coordinates of host machine's display
  55. : ScreenBits
  56.     $ 904 -base @ -base @ -base 116 -
  57.     dup    @ unpack
  58.     rot 4+ @ unpack
  59. ;
  60.  
  61. \ define the basic Window class, which has no controls
  62. :CLASS Window  <Super GrafPort
  63.  
  64.     $ 20 Bytes    wind1    \ unmapped
  65.     Handle        Ctllist    \ 1st ctl
  66.     $ 0C Bytes    wind2    \ unmapped
  67.  
  68.     Rect    contRect    \ true content
  69.     Rect    growRect    \ grow size rectangle
  70.     Rect    dragRect    \ Drag limits rect
  71.     Int        growFlg        \ true if growable
  72.     Int        dragFlg        \ true if draggable
  73.     Int        Alive        \ true if space exists
  74.     Var        Idle        \ cfa- idle handler
  75.     Var        Deact        \ cfa- deactivate event handler
  76.  
  77.     Var        Content        \ cfa- content handler
  78.     Var        Draw        \ cfa- draw handler
  79.     Var        Enact        \ cfa- activate event handler
  80.     Var        Close        \ cfa- close handler
  81.     Int        Resid        \ Resource ID
  82.     int        scrollFlg    \ flag to not update fprect for scrolling
  83.     Var        Zoom        \ cfa- zoom word
  84.  
  85. \ add color support
  86.  
  87.     int    ?color            \ true if want a color window
  88.     palette myPalette
  89.     int ColorUsage
  90.     int #colors            \ how many colors in this window
  91.  
  92. \ Cwindow related things...
  93.  
  94. ( b --)    \ set this to true if want the window to be created as a color window
  95.   :M color: put: ?color ;M
  96.  
  97. ( usage --)
  98.   :M usage: put: ColorUsage ;M
  99.  
  100.   :M put#Colors: put: #colors ;M
  101.  
  102.   :M makePalette: get: ColorUsage usage: myPalette
  103.         get: #colors new: myPalette ^base putWindow: myPalette
  104.         fillgray: myPalette set: myPalette ;M
  105.  
  106.   :M erase: pushPort set: self clear: portRect popPort ;M
  107.  
  108. \ gets handle to window's palette and puts into global palette for operations
  109.   :M getPalette: 0 abs: self call GetPalette put: thePalette 
  110.         ^base putWindow: thePalette get: #colors putSize: thePalette
  111.         get: colorUsage usage: thePalette ;M
  112.  
  113. \ Normal window things
  114.  
  115. \ set drag and grow limits based on multiple screen regions
  116.     :M  SETLIMITS: grayRgn put: dragRect
  117.         40 40 size: dragRect put: growRect
  118.         4 4 inset: dragRect true put: dragFlg true put: growFlg ;M
  119.  
  120.     :M  SETZOOM: put: Zoom ;M
  121.  
  122.     :M  SETSCROLL: put: scrollFlg ;M
  123.  
  124.     :M  SETFPRECT: get: scrollFlg IF get: contRect put: fPrect THEN ;M
  125.  
  126.     \ ( -- )  update the Forth output, scrolling rects
  127.     :M  SETVIEW: get: portRect get: growFlg
  128.         IF swap 15 - swap 15 - THEN  put: contRect
  129.         setfPrect: self ;M
  130.  
  131.     \ ( n --)
  132.     :M  PUTRESID: put: resID ;M
  133.     \ ( -- )
  134.     :M  CLOSE:  get: alive
  135.         IF (abs) call CloseWindow
  136.             get: ?color IF dispose: myPalette THEN
  137.             clear: alive  exec: close
  138.         THEN  ;M
  139.  
  140.     \ ( -- )  Make this wind the current GrafPort
  141.     :M  SET:  set: super setfPrect: self ;M
  142.  
  143.     :M  PORTBIT: ( -- abs) (abs) 2+ ;M
  144.  
  145.     \ update window with its entire port rectangle as the update region.
  146.     :M  UPDATE: pushPort set: self
  147.         getRect: self  put: tempRect  update: tempRect
  148.         popPort ;M
  149.  
  150.     :M InitNewWindow: setView: [ ^base ]
  151.         set: self initFont true put: alive cls ;M
  152.  
  153.     :M PenIntoWind: @xy bottom min gotoxy ;M
  154.  
  155.     \ Define a new window on heap with specified features
  156.     :M  NEW:  { bndsRect tAddr tLen procID vis goAway -- }
  157.         Get: Alive  0=
  158.         IF    0 (abs)  bndsrect +base  taddr tlen str255 vis bool
  159.             procID  makeInt inFront  goAway bool  0
  160.             get: ?color
  161.             IF call newCWindow makePalette: self ELSE call NewWindow THEN
  162.             drop   initNewWindow: self
  163.         THEN  ;M
  164.  
  165.     \ ( -- )  new window from resource file
  166.     :M  GETNEW:   get: alive  0=
  167.         IF  0 int: resid (abs) infront
  168.             get: ?color
  169.             IF call GetNewCWindow makePalette: self ELSE call GetNewWindow THEN
  170.             0= classerr" 170
  171.             initNewWindow: self select: [ ^base ] 
  172.         THEN   ;M
  173.  
  174.     \ ( -- l t r b )  Return the vert. scroll bar rect
  175.     :M  GETVRECT:  GetBotx: portRect  15 -
  176.         GetTopy: portRect 1- getBotX: portRect 1+
  177.         getBotY: portRect 14 - ;M
  178.  
  179.     \ ( -- l t r b )  Return the horizontal scroll bar rect
  180.     :M  GETHRECT: getTopX: portRect 1- getBotY: portRect 15 -
  181.         getBotX: portRect 14 - getBotY: portRect 1+ ;M
  182.  
  183.     \ ( -- )  update content area
  184.     :M  DRAW:    get: fPrect
  185.         (abs) call BeginUpdate
  186.         savePort @xy set: self
  187.         get: growFlg
  188.         IF    @xy (abs)  call DrawGrowIcon
  189.             gotoxy
  190.         THEN
  191.         exec: draw   restport gotoxy    \ call user draw routine
  192.         (abs) call EndUpdate 
  193.         put: fPrect  ;M
  194.  
  195.     \ ( -- )  Make this the front window
  196.     :M  SELECT:   (abs)  call SelectWindow setfPrect: self ;M
  197.  
  198.     \ The idle: method is normally called, (after executing the system tasks),
  199.     \ for the front-most window, whenever a null event occurs. It should be a
  200.     \ window-specific task.  NULL-EVT is the normal word which sends idle:
  201.     :M  IDLE:    exec: idle ;M
  202.  
  203.     \ ( cfa -- )  Install a null event handler for this window
  204.     :M  SETIDLE: put: idle  ;M
  205.  
  206.     \ ( -- )  response to activate event
  207.     :M  ENABLE:  ^base -> actW                \ commence idle handler
  208.         set: self
  209.         get: growFlg IF @xy (abs) call DrawGrowIcon gotoxy THEN
  210.         exec: Enact  ;M
  211.  
  212.     \ ( -- )  response to deactivate event
  213.     :M  DISABLE: 0 -> actW
  214.         get: growFlg
  215.         IF @xy (abs) call DrawGrowIcon gotoxy THEN
  216.         exec: deact ;M   \ cease idle handler
  217.  
  218.     \ ( enact deact -- )  Set the activate/deactivate event handlers
  219.     :M  SETACT:  put: Deact put: Enact  ;M
  220.  
  221.     \ ( -- b )  is this window active ?
  222.     :M  ACTIVE:  0 call FrontWindow (abs)  =    ;M
  223.  
  224.     \ ( -- b )  is this window alive?
  225.     :M  ALIVE:   get: alive   ;M
  226.  
  227.     \ ( -- )  response to drag region click
  228.     :M  DRAG:  get: dragFlg
  229.         IF (abs)  Where: fEvent  abs: dragRect
  230.             call DragWindow
  231.         THEN  ;M
  232.  
  233.     :M ERASEGROW: get: growFlg
  234.         IF  getVRect: self 16 + put: tempRect
  235.             clear: tempRect update: tempRect
  236.             getHRect: self put: temprect clear: temprect  update: tempRect
  237.         THEN ;M
  238.  
  239.     :M FIXGROW: eraseGrow: self setView: [ ^base ] penIntoWind: self ;M
  240.  
  241.     \ ( w h -- )  reSize window and accumulate update regions
  242.     :M  SIZE:    pack  (abs)  swap  True makeInt
  243.         eraseGrow: self
  244.         call SizeWindow    \ resize the window
  245.         fixGrow: self    ;M
  246.  
  247.     :M  ZOOM: { part -- } word0 (abs) where: fEvent
  248.         part makeint call TrackBox i->l
  249.         IF     eraseGrow: self get: zoom
  250.             IF   part 7 - exec: zoom                        \ execute special zoom
  251.             ELSE (abs) part makeint word0 call zoomWindow    \ default zoom
  252.             THEN
  253.             fixGrow: self
  254.         THEN ;M
  255.  
  256.     \ ( -- )  Handle a content click
  257.     :M  CONTENT:  Active: self
  258.         IF    exec: content    \ call the content handler
  259.         ELSE  (abs) call SelectWindow
  260.         THEN  ;M
  261.  
  262.     \ ( -- )  response to grow region click
  263.     :M  GROW:  Get: growFlg
  264.         IF  0 (abs) Where: fEvent  abs: growrect
  265.             call GrowWindow  -dup
  266.             IF  unpack size: self draw: self update: self
  267.                 penIntoWind: self    \ go to new bottom
  268.             THEN
  269.         ELSE content: self
  270.         THEN  ;M
  271.  
  272.  
  273.     \ ( close enact draw cont -- )  init window  event handler words
  274.     :M  ACTIONS:   put: content  put: draw  put: enact
  275.         put: close  ;M
  276.  
  277.     \ ( addr len -- )
  278.     :M  TITLE:   str255 (abs) swap  call SetWTitle  ;M
  279.  
  280.     \ ( addr len -- )  Name: is for string class compatibility
  281.     :M  NAME:  title: self  ;M
  282.  
  283.     \ ( -- addr len )  return name of window
  284.     :M  GETNAME:  (abs)  buf255 +base call GetWTitle
  285.         buf255 count   ;M
  286.  
  287.     \ ( x y -- )
  288.     :M  MOVETO:   Pack (abs) swap false makeInt
  289.         call MoveWindow   ;M
  290.  
  291.     :M  CENTER: { \ sw sh pw ph -- }
  292.         screenBits -> sh -> sw 2drop
  293.         size: portRect -> ph -> pw
  294.         sw pw - 2/  sh ph - 2/  moveto: self ;M
  295.         
  296.  
  297.     :M  CUT:   null ;M
  298.     :M  COPY:  null ;M
  299.     :M  PASTE: null ;M
  300.     :M  CLEAR: null ;M
  301.  
  302.     \ ( chr -- )  just drop keys
  303.     :M  KEY:   drop ;M
  304.  
  305.     \ ( -- )   Make this window visible
  306.     :M  SHOW:   (abs)  call ShowWindow ;M
  307.  
  308.     \ ( -- )   Make this window visible
  309.     :M  HIDE:   (abs)  call HideWindow ;M
  310.  
  311.     \ ( l t r b  t OR f -- )  set grow limits
  312.     :M  SETGROW:    DUP put: GrowFlg
  313.         IF  put: growrect THEN ;M
  314.  
  315.     \ ( l t r b  t OR f -- )  Set drag limits
  316.     :M  SETDRAG:  dup  Put: dragFlg
  317.         IF Put: dragRect THEN  ;M
  318.  
  319.     \ ( cfa -- )  set the draw handler
  320.     :M  SETDRAW:  put: draw  ;M
  321.  
  322.     :M  CLASSINIT:
  323.         <[ 4 ]> 'cfas  null null null null actions: self
  324.         'c null put: idle
  325.         'c null put: deact
  326.         pmCourteous usage: self 256 put: #Colors
  327.     ;M
  328.  
  329.     \ ( -- )  show an example of Window; use grayRgn for drag limits
  330.     :M EXAMPLE:  100 100 300 200 put: tempRect    \ set size of window
  331.         tempRect  " Example"
  332.         docWind  true true  new: self
  333.         setLimits: self  ;M
  334.  
  335.     :M SELECTALL: null ;M
  336.  
  337.     :M UNDO: null ;M
  338.  
  339. ;CLASS
  340.  
  341. ' Window 'c fWind !
  342.